home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tm / tm-rmail.el.z / tm-rmail.el
Encoding:
Text File  |  1998-05-21  |  10.3 KB  |  399 lines
  1. ;;; tm-rmail.el --- MIME extension for RMAIL
  2.  
  3. ;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc.
  4.  
  5. ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  6. ;; modified by KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp>
  7. ;; Created: 1994/8/30
  8. ;; Version: $Revision: 7.30 $
  9. ;; Keywords: mail, MIME, multimedia, multilingual, encoded-word
  10.  
  11. ;; This file is not part of tm (Tools for MIME).
  12.  
  13. ;; This program is free software; you can redistribute it and/or
  14. ;; modify it under the terms of the GNU General Public License as
  15. ;; published by the Free Software Foundation; either version 2, or (at
  16. ;; your option) any later version.
  17.  
  18. ;; This program is distributed in the hope that it will be useful, but
  19. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21. ;; General Public License for more details.
  22.  
  23. ;; You should have received a copy of the GNU General Public License
  24. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;; Boston, MA 02111-1307, USA.
  27.  
  28. ;;; Code:
  29.  
  30. (require 'tl-list)
  31. (require 'tl-misc)
  32. (require 'rmail)
  33.  
  34. (autoload 'mime/viewer-mode "tm-view" "View MIME message." t)
  35. (autoload 'mime/Content-Type "tm-view" "parse Content-Type field.")
  36. (autoload 'mime/decode-message-header "tm-ew-d" "Decode MIME encoded-word." t)
  37.  
  38.  
  39. ;;; @ variables
  40. ;;;
  41.  
  42. (defconst tm-rmail/RCS-ID
  43.   "$Id: tm-rmail.el,v 7.30 1997/02/13 12:43:39 morioka Exp $")
  44. (defconst tm-rmail/version (get-version-string tm-rmail/RCS-ID))
  45.  
  46. (defvar tm-rmail/decode-all nil)
  47.  
  48.  
  49. ;;; @ message filter
  50. ;;;
  51.  
  52. (setq rmail-message-filter
  53.       (function
  54.        (lambda ()
  55.      (let ((mf (buffer-modified-p))
  56.            (buffer-read-only nil))
  57.        (mime/decode-message-header)
  58.        (set-buffer-modified-p mf)
  59.        ))))
  60.  
  61.  
  62. ;;; @ MIME preview
  63. ;;;
  64.  
  65. (defun tm-rmail/show-all-header-p ()
  66.   (save-restriction
  67.     (narrow-to-region (point-min)
  68.               (and (re-search-forward "^$" nil t)
  69.                (match-beginning 0)))
  70.     (goto-char (point-min))
  71.     (re-search-forward rmail-ignored-headers nil t)
  72.     ))
  73.  
  74. (defun tm-rmail/preview-message ()
  75.   (interactive)
  76.   (setq tm-rmail/decode-all t)
  77.   (let ((ret (tm-rmail/get-Content-Type-and-Content-Transfer-Encoding)))
  78.     (narrow-to-region (point-min)
  79.               (save-excursion
  80.             (goto-char (point-max))
  81.             (if (and (re-search-backward "^\n")
  82.                  (eq (match-end 0)(point-max)))
  83.                 (match-beginning 0)
  84.               (point-max)
  85.               )))
  86.     (let ((abuf (current-buffer))
  87.       (buf-name (format "*Preview-%s [%d/%d]*"
  88.                 (buffer-name)
  89.                 rmail-current-message rmail-total-messages))
  90.       buf win)
  91.       (if (and mime::article/preview-buffer
  92.          (setq buf (get-buffer mime::article/preview-buffer))
  93.          )
  94.       (progn
  95.         (save-excursion
  96.           (set-buffer buf)
  97.           (rename-buffer buf-name)
  98.           )
  99.         (if (setq win (get-buffer-window buf))
  100.         (progn
  101.           (delete-window (get-buffer-window abuf))
  102.           (set-window-buffer win abuf)
  103.           (set-buffer abuf)
  104.           ))
  105.         ))
  106.       (setq win (get-buffer-window abuf))
  107.       (save-window-excursion
  108.     (mime/viewer-mode nil (car ret)(cdr ret) nil buf-name)
  109.     (or buf
  110.         (setq buf (current-buffer))
  111.         )
  112.     )
  113.       (set-window-buffer win buf)
  114.       )))
  115.  
  116. (defun tm-rmail/preview-message-if-you-need ()
  117.   (if tm-rmail/decode-all
  118.       (tm-rmail/preview-message)
  119.     ))
  120.  
  121. (add-hook 'rmail-show-message-hook 'tm-rmail/preview-message-if-you-need)
  122.  
  123. (load "rmailsum")
  124.  
  125. (cond ((fboundp 'rmail-summary-rmail-update)
  126.        ;; for Emacs 19 or later
  127.        (or (fboundp 'tm:rmail-summary-rmail-update)
  128.        (fset 'tm:rmail-summary-rmail-update
  129.          (symbol-function 'rmail-summary-rmail-update))
  130.        )
  131.        
  132.        (defun rmail-summary-rmail-update ()
  133.      (tm:rmail-summary-rmail-update)
  134.      (if tm-rmail/decode-all
  135.          (let ((win (get-buffer-window rmail-buffer)))
  136.            (if win
  137.            (delete-window win)
  138.          )))
  139.      )
  140.        
  141.        (defun tm-rmail/get-Content-Type-and-Content-Transfer-Encoding ()
  142.      (rmail-widen-to-current-msgbeg
  143.       (function
  144.        (lambda ()
  145.          (cons (mime/Content-Type)
  146.            (mime/Content-Transfer-Encoding "7bit")
  147.            )))))
  148.        )
  149.       (t
  150.        ;; for Emacs 18
  151.        (defun tm-rmail/get-Content-Type-and-Content-Transfer-Encoding ()
  152.      (save-restriction
  153.        (rmail-widen-to-current-msgbeg
  154.         (function
  155.          (lambda ()
  156.            (goto-char (point-min))
  157.            (narrow-to-region (or (and (re-search-forward "^.+:" nil t)
  158.                       (match-beginning 0))
  159.                      (point-min))
  160.                  (point-max))
  161.            )))
  162.        (cons (mime/Content-Type)
  163.          (mime/Content-Transfer-Encoding "7bit")
  164.          )))
  165.        ))
  166.  
  167. (define-key rmail-mode-map "v" (function tm-rmail/preview-message))
  168.  
  169. (defun tm-rmail/setup ()
  170.   (local-set-key "v" (function
  171.               (lambda ()
  172.             (interactive)
  173.             (set-buffer rmail-buffer)
  174.             (tm-rmail/preview-message)
  175.             )))
  176.   )
  177.  
  178. (add-hook 'rmail-summary-mode-hook 'tm-rmail/setup)
  179.  
  180.  
  181. ;;; @ over-to-* and quitting methods
  182. ;;;
  183.  
  184. (defun tm-rmail/quitting-method-to-summary ()
  185.   (mime-viewer/kill-buffer)
  186.   (rmail-summary)
  187.   (delete-other-windows)
  188.   )
  189.  
  190. (defun tm-rmail/quitting-method-to-article ()
  191.   (setq tm-rmail/decode-all nil)
  192.   (let ((buffer
  193.      (mime::preview-content-info/buffer
  194.       (mime-preview/point-pcinfo (point))))
  195.     )
  196.     (mime-viewer/kill-buffer)
  197.  
  198.     ;;  Make sure we return to RMAIL buffer
  199.     (if buffer
  200.     (switch-to-buffer buffer))
  201.     ))
  202.  
  203. (defalias 'tm-rmail/quitting-method 'tm-rmail/quitting-method-to-article)
  204.  
  205.  
  206. (defun tm-rmail/over-to-previous-method ()
  207.   (let (tm-rmail/decode-all)
  208.     (mime-viewer/quit)
  209.     )
  210.   (if (not (eq (rmail-next-undeleted-message -1) t))
  211.       (tm-rmail/preview-message)
  212.     )
  213.   )
  214.  
  215. (defun tm-rmail/over-to-next-method ()
  216.   (let (tm-rmail/decode-all)
  217.     (mime-viewer/quit)
  218.     )
  219.   (if (not (eq (rmail-next-undeleted-message 1) t))
  220.       (tm-rmail/preview-message)
  221.     )
  222.   )
  223.  
  224. (defun tm-rmail/show-summary-method ()
  225.   (save-excursion
  226.     (set-buffer mime::preview/article-buffer)
  227.     (rmail-summary)
  228.     ))
  229.  
  230. (call-after-loaded
  231.  'tm-view
  232.  (function
  233.   (lambda ()
  234.     (set-alist 'mime-viewer/quitting-method-alist
  235.            'rmail-mode
  236.            (function tm-rmail/quitting-method))
  237.     
  238.     (set-alist 'mime-viewer/over-to-previous-method-alist
  239.            'rmail-mode
  240.            (function tm-rmail/over-to-previous-method))
  241.     
  242.     (set-alist 'mime-viewer/over-to-next-method-alist
  243.            'rmail-mode
  244.            (function tm-rmail/over-to-next-method))
  245.  
  246.     (set-alist 'mime-viewer/show-summary-method
  247.            'rmail-mode
  248.            (function tm-rmail/show-summary-method))
  249.     )))
  250.  
  251.  
  252. ;;; @ for tm-partial
  253. ;;;
  254.  
  255. (call-after-loaded
  256.  'tm-partial
  257.  (function
  258.   (lambda ()
  259.     (set-atype 'mime/content-decoding-condition
  260.            '((type . "message/partial")
  261.          (method . mime-article/grab-message/partials)
  262.          (major-mode . rmail-mode)
  263.          (summary-buffer-exp
  264.           . (progn
  265.               (rmail-summary)
  266.               (pop-to-buffer rmail-buffer)
  267.               rmail-summary-buffer))
  268.          ))
  269.     (set-alist 'tm-partial/preview-article-method-alist
  270.            'rmail-mode
  271.            (function
  272.         (lambda ()
  273.           (rmail-summary-goto-msg (count-lines 1 (point)))
  274.           (pop-to-buffer rmail-buffer)
  275.           (tm-rmail/preview-message)
  276.           )))
  277.     )))
  278.  
  279.  
  280. ;;; @ for tm-edit
  281. ;;;
  282.  
  283. (defun tm-rmail/forward ()
  284.   "Forward current message in message/rfc822 content-type message
  285. from rmail. The message will be appended if being composed."
  286.   (interactive)
  287.   ;;>> this gets set even if we abort. Can't do anything about it, though.
  288.   (rmail-set-attribute "forwarded" t)
  289.   (let ((initialized nil)
  290.     (beginning nil)
  291.     (msgnum rmail-current-message)
  292.     (rmail-buffer (current-buffer))
  293.     (subject (concat "["
  294.              (mail-strip-quoted-names
  295.               (mail-fetch-field "From"))
  296.              ": " (or (mail-fetch-field "Subject") "") "]")))
  297.     ;; If only one window, use it for the mail buffer.
  298.     ;; Otherwise, use another window for the mail buffer
  299.     ;; so that the Rmail buffer remains visible
  300.     ;; and sending the mail will get back to it.
  301.     (setq initialized
  302.       (if (one-window-p t)
  303.           (mail nil nil subject)
  304.         (mail-other-window nil nil subject)))
  305.     (save-excursion
  306.       ;; following two variables are used in 19.29 or later.
  307.       (make-local-variable 'rmail-send-actions-rmail-buffer)
  308.       (make-local-variable 'rmail-send-actions-rmail-msg-number)
  309.       (make-local-variable 'mail-reply-buffer)
  310.       (setq rmail-send-actions-rmail-buffer rmail-buffer)
  311.       (setq rmail-send-actions-rmail-msg-number msgnum)
  312.       (setq mail-reply-buffer rmail-buffer)
  313.       (goto-char (point-max))
  314.       (forward-line 1)
  315.       (setq beginning (point))
  316.       (mime-editor/insert-tag "message" "rfc822")
  317. ;;       (insert-buffer rmail-buffer))
  318. ;;       (mime-editor/inserted-message-filter))
  319.       (tm-mail/insert-message))
  320.     (if (not initialized)
  321.     (goto-char beginning))
  322.     ))
  323.  
  324. (defun gnus-mail-forward-using-mail-mime ()
  325.   "Forward current article in message/rfc822 content-type message from
  326. GNUS. The message will be appended if being composed."
  327.   (let ((initialized nil)
  328.     (beginning nil)
  329.     (forwarding-buffer (current-buffer))
  330.     (subject
  331.      (concat "[" gnus-newsgroup-name "] "
  332.          ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": "
  333.          (or (gnus-fetch-field "Subject") ""))))
  334.     ;; If only one window, use it for the mail buffer.
  335.     ;; Otherwise, use another window for the mail buffer
  336.     ;; so that the Rmail buffer remains visible
  337.     ;; and sending the mail will get back to it.
  338.     (setq initialized
  339.       (if (one-window-p t)
  340.           (mail nil nil subject)
  341.         (mail-other-window nil nil subject)))
  342.     (save-excursion
  343.       (goto-char (point-max))
  344.       (setq beginning (point))
  345.       (mime-editor/insert-tag "message" "rfc822")
  346.       (insert-buffer forwarding-buffer)
  347.       ;; You have a chance to arrange the message.
  348.       (run-hooks 'gnus-mail-forward-hook)
  349.       )
  350.     (if (not initialized)
  351.     (goto-char beginning))
  352.     ))
  353.  
  354. (call-after-loaded
  355.  'mime-setup
  356.  (function
  357.   (lambda ()
  358.     (substitute-key-definition
  359.      'rmail-forward 'tm-rmail/forward rmail-mode-map)
  360.     
  361.     ;; (setq gnus-mail-forward-method 'gnus-mail-forward-using-mail-mime)
  362.     
  363.     (call-after-loaded
  364.      'tm-edit
  365.      (function
  366.       (lambda ()
  367.     (require 'tm-mail)
  368.     (set-alist 'mime-editor/message-inserter-alist
  369.            'mail-mode (function tm-mail/insert-message))
  370.     (set-alist 'mime-editor/split-message-sender-alist
  371.            'mail-mode (function
  372.                    (lambda ()
  373.                  (interactive)
  374.                  (funcall send-mail-function)
  375.                  )))
  376.     )))
  377.     )))
  378.  
  379.  
  380. ;;; @ for BBDB
  381. ;;;
  382.  
  383. (call-after-loaded
  384.  'bbdb
  385.  (function
  386.   (lambda ()
  387.     (require 'tm-bbdb)
  388.     )))
  389.  
  390.  
  391. ;;; @ end
  392. ;;;
  393.  
  394. (provide 'tm-rmail)
  395.  
  396. (run-hooks 'tm-rmail-load-hook)
  397.  
  398. ;;; tm-rmail.el ends here.
  399.